perm filename MOVER.F4[Y,MUS] blob
sn#067313 filedate 1973-12-01 generic text, type T, neo UTF8
00010 C**** SUBR. MOVER FUNC. RTLINE
00100 SUBROUTINE MOVER
00200 IMPLICIT INTEGER(A-Q,S-Z)
00300 DIMENSION R(2,40),IR(2,40)
00400 REAL PWDS,POS
00500 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK/STF/RSTFAC(8),RSTJC
00600 COMMON/ALF/INP(72),ML/XRN/RN(4000)
00700 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00800 COMMON/POSI/STFF(8),JJB,POS/PTR/PWDS(250),ITEM,L,I,IX
00900 EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
01000 1,(RJC,RJQ(1)),(RJH,RJQ(6)),(RJI,RJQ(7)),(RJK,RJQ(9))
01100 1,(IR,R,RN(3921))
01200 DATA F78F/'(78F)'/,FA1/'(A1 )'/,FA5/'(A5 )'/
01300
01400 JJB=-1
01500 CC ROV=1000
01600 JB=0
01700 C 99=BACKUP
01900 6 CALL VLINE(RJC,RJD,RJE,RJF)
02000 IF(RJC.EQ.99)RETURN
02100 IF(INP(1).NE.'J')GO TO 12
02300 RRT=RJE
02400 RZRO=RJD
02500 IF(RRT.EQ.0)RRT=200
02900 IF(RZRO.EQ.0)RZRO=.001
03000 RCNT=0
03200 RJSZ=5.0
03300 ASK=-1
03500 RJG=RJC
03600 RJF=0
03700 RJK=0
03800 19 ROV=RRT
03900 RJSZ=RJSZ-.1
04000 RCNT=RCNT+1
04100 C TEMPORARY COUNTER
04200 ML=1
04300 TYPE F78F,RCNT
04400
04500 DO 11 KN=-3,4
04600 RSPC=0
04700 RJH=KN
04800 N=0
04900 DO 2 K=1,ITEM
05000 L=PWDS(K)
05100 IF(RTLINE(L))GO TO 2
05200 RA=RN(L+1)
05300 RB=RN(L+2)
05400 IF((RN(L+3).NE.RJH.AND.RA.NE.4).OR.RB.LT.RZRO)GO TO 2
05500 IF(RA.NE.1)GO TO 27
05600 IF(ABS(RN(L+6)).GE.2)GO TO 2
05700 C SKIPS HOMED NOTES (IN CHORDS)
05800 GO TO 10
05900 27 IF(RA.GT.4.AND.RA.NE.18.AND.RA.NE.7)GO TO 2
06000 IF(RA.EQ.4.AND.RN(L).GT.2)GO TO 2
06100 C SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
06200 10 N=N+1
06300 R(1,N)=RB
06400 IR(2,N)=L
06500 IF(N.EQ.40)GO TO 28
06600 C ONLY TREATS 40 ITEMS AT A TIME.
06700 2 CONTINUE
06800 IF(N.EQ.0)GO TO 11
06900 28 DO 23 K=1,N
07000 23 IF(RN(IR(2,K)+1).NE.4)GO TO 24
07100 C SKIPS IF ONLY BAR LINES ON THIS STAFF
07200 GO TO 11
07300 24 RSTJC=RSTFAC(KN+4)
07400 CC N=N-1
07500 CALL SORT2(R,N)
07600
07700 CC IF(RN(IR(2,N)+1).EQ.4)GO TO 22
07800 C JUMP IF LAST IS A BAR LINE.
07900 CC N=N+1
08000 CC R(1,N)=ROV
08100 CC R(2,N)=3
08200 22 DO 3 K=1,N
08300 L=IR(2,K)
08400 RA=RN(L+1)
08500 RB=0
08600 RX=RN(L+5)
08610 RY=1
08620 RW=AMOD(RN(L+4),100.)
08700 IF(RA.GT.1)GO TO 4
08710 RZ=RN(L+7)
08800 IF((AMOD(RZ,10.).NE.0.AND.RX.LT.20).OR.RZ.GE.10)RB=1.5
08900 C SPACE FOR DOT OR TAIL(IF STEM UP)
08920 IF(RW.GT.11.OR.RW.LT.2)RB=1.5
08947 C SPACE FOR LEDGER LINES
08975 IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
09000 IF(AMOD(RX,10.).EQ.0)GO TO 17
09100 RD=2*RY
09200 25 R(2,K-1)=RC+RD*RSTJC
09300 GO TO 17
09400 4 IF(RA.NE.3)GO TO 29
09500 RB=3
09600 IF(RX.GT.100)RB=.8
09800 C CHECK ON SIZE NEEDED FOR CLEFS
09900 29 IF(RA.NE.4)GO TO 26
10000 RB=-RJSZ/2
10100 RD=.9
10200 GO TO 25
10210 26 IF(RA.NE.18)GO TO 30
10220 IF(RW.GT.9.OR.RX.GT.9)GO TO 31
10230 RB=-1
10240 RD=1
10250 GO TO 25
10260 31 RB=2
10270 RD=3
10280 GO TO 25
10400 30 IF(RA.EQ.7)RB=2*(ABS(RW)-1)
10500 C SPACES FOR CORRECT NUM OF ACCIS.
10700 C CHECKS FOR 2-DIGIT METERS
10800 17 RC=(RB+RJSZ)*RSTJC
10810 C RJSZ=DEFAULT SIZE
10900 3 R(2,K)=RC
11000 RA=R(1,1)
11100 RB=R(2,1)
11200
11300 DO 13 KX=2,N
11400 RC=R(1,KX)
11500 IF(RC.EQ.RA)GO TO 16
11600 C SKIPS DOUBLE STOPS
11700 CC IF(RB)RB=2*RSTJC-RB
11800 14 RD=RA+RB-RC
11900 IF(RD.LE.0)GO TO 16
12000 C THERE'S ENOUGH ROOM
12100 CC RD=RA+RB-RC+RD
12200 RJD=RC+RSPC-.001
12300 RJE=1000
12400 RJH=RD
12500 RJI=0
12600 RSPC=RSPC+RD
12700 C RSPC SAVES TOTAL SPACE ADDED
12800 C GO EXPAND IT
12900 IF(R(2,KX).NE.0)GO TO 166
13000 16 RB=R(2,KX)
13100 13 RA=RC
13200 11 CONTINUE
13300 IF(ROV.LE.RRT+.01)GO TO 18
13400 RJD=RZRO
13500 RJE=ROV
13600 RJH=RZRO
13700 RJI=RRT-.001
13800 C JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
13900 ML=3
14000 IF(RJSZ.GT.4)RJSZ=4
14100 GO TO 66
14200 18 ML=4
14400 RJH=ROV
14500 RJI=RRT+2
14510 C GOES BACK TO PICK UP DANGLING ITEMS(BEYOND RRT)
14600 RJD=ROV
14700 RJE=500
14800 166 JJB=-1
14900 JB=0
15000 GO TO 66
15100 12 TYPE 5
15200 ML=2
15300 ACCEPT F78F,RJG,RJH,RJI,RJK
15400 REREAD FA1,L
15500 C FOR LPEN TYPE 'L'. BUT 4TH # MUST APPEAR WHEN NEEDED.
15600 IF(RJG.EQ.99)GO TO 6
15700 IF(L.NE.'L')GO TO 66
15800 DO 67 K=1,2
15900 RJH=RY
16000 CALL LPEN(RJG,RY,RX)
16100 67 IF(RJG.EQ.99)GO TO 6
16200 RJI=RY
16300 66 JY=1
16400 L=JY
16500 IF(INP(1).EQ.'C')L=I
16600 C C=COPY
16700 RDIS=0
16800 IF(RJI.NE.0)RDIS=(RJI-RJH)/(RJE-RJD)
16900
17000 6551 RB=RN(JY)
17100 JB=JB+1
17200 IF(RTLINE(JY))GO TO 7551
17300 C IF STAFF#>4, ALL STAVES ARE MOVED.
17400 RA=RN(JY+1)
17500 IF(RJF.GT.0.AND.RJF.NE.RA)GO TO 7551
17600 C SKIPS IF NOT SPECIAL CODE NUM.
17700 RN2=RN(JY+2)
17800 IF(RN2.GT.RJE)GO TO 7551
17900 RC=-1
18000 RD=0
18100 IF(RA.EQ.8.OR.RA.EQ.9.OR.RA.EQ.20)RD=-1
18200 IF(RA.EQ.4..OR.RD.OR.RN(JY+5).EQ.50)RC=0
18300 C RC=0 FOR CODES 4,8,9
18400 RN6=RN(JY+6)
18500 IF(RN2.GE.RJD)GO TO 8
18600 IF(RC.OR.(RC.EQ.0.AND.(RN6.LE.RJD.OR.RN6.GE.RJE)))GO TO 7551
18700 C RIGHT SIDE IS BEFORE OR AFTER MOVE AREA.
18800 C IF INP(1)='C' MOVE TO NEW SPOT AND LEAVE OLD BEHIND.
18900 8 IF(ASK)GO TO 100
19000 CALL ASKIT
19100 IF(K.EQ.'N')GO TO 7551
19200 IF(K.EQ.'X')GO TO 1
19300 C 'X'=EXIT
19400 C N=NO, <CR>=YES
19500 100 IF(INP(1).NE.'C')GO TO 9551
19600 K=RB+2
19700 CALL LOOP(0,K,1,L,JY,RN)
19800 ITEM=ITEM+1
19900 IF(JJB)JJB=ITEM
20000 C JJB SAVES ITEM # FOR MAIN PROG.
20100 PWDS(ITEM+1)=L+K+1
20200 9551 IF(JJB)JJB=JB
20300 C (50=CRESC., DECRESC.)
20400 IF(RJC.LT.5)RN(L+3)=RJG
20500 C RJG IS NEW STAFF NUM.
20600 RQ6=RN6-RJE
20700 RX=0
20800 IF(RA.NE.9.OR.RB.LT.7)GO TO 21
20900 RX=RN(L+9)
21000 RY=RX-RJE
21100 RZ=RJD-RX
21200 IF(RY.AND.RZ)RX=-1
21300 C PARTIAL BEAM IS WITHIN MOVE AREA.
21400 21 IF(RJI.EQ.0)GO TO 2551
21500 IF(RN2.GE.RJD)RN(L+2)=RJH+(RN2-RJD)*RDIS
21600 IF(RC)GO TO 7552
21700 IF(RA.EQ.4..AND.RB.LT.4)GO TO 7552
21800 IF(RQ6)RN(L+6)=RJH+(RN(JY+6)-RJD)*RDIS
21900 C END POINT OUTSIDE OF MOVE RANGE NOT AFFECTED.
22000 IF(RA.NE.9)GO TO 7552
22100 IF(RX)RN(L+9)=RJH+(RN(JY+9)-RJD)*RDIS
22200 C ONLY TRUE WHEN RA=9
22300 GO TO 7552
22400
22500 2551 IF(RN2.GE.RJD)RN2=RN2+RJH
22600 RN(L+2)=RN2
22700 IF(RQ6.AND.(RD.OR.(RA.EQ.4.AND.RB.GT.3.)))RN(L+6)=RN(JY+6)+RJH
22800 IF(RX)RN(L+9)=RN(JY+9)+RJH
22900 IF(RN2.GT.ROV)ROV=RN2
23000 C NOT YET FIXED FOR ENDS OF SLURS OR LINES
23100 7552 L=RB+3+L
23200 IF(RJK.EQ.0)GO TO 7551
23300 1551 IF((RB.LT.3..AND.RA.NE.6.).OR.RA.EQ.18)GO TO 7551
23400 C 'U-D' SKIPS METER, STAFF, ETC.
23500 JX=JY
23600 IF(INP(1).EQ.'C')JX=PWDS(ITEM)
23700 RN(JX+4)=RN(JX+4)+RJK
23800 IF(RC.EQ.0)RN(JX+5)=RN(JX+5)+RJK
23900 7551 JY=RB+3+JY
24000 IF(INP(1).NE.'C')L=JY
24100 IF(JY.LT.I)GO TO 6551
24200 GO TO (16,1,19,101),ML
24300 101 JJB=1
24400 1 CALL HYDPOG(3)
24500 5 FORMAT(' TYPE NEW STAFF #, POS1, POS2, UP-DOWN #'/)
24600 END
24700
24900 FUNCTION RTLINE(L)
25000 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/XRN/RN(4000)
25050 RTLINE=-1
25100 IF(RJQ(1).GT.4.OR.RN(L+3).EQ.RJQ(1))RTLINE=0
25200 END